perm filename PARSE.DES[AL,HE] blob
sn#329156 filedate 1978-07-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00016 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002
C00004 00003 ! statement, operator
C00010 00004 ! hash, check_entry, insert_entry
C00012 00005 ! ------- DECLARATIONS ----------
C00014 00006 ! ----- SYMBOL TABLE variables -----
C00018 00007 ! ----- SYMBOL TABLE EXTRACTION AND INSERTION FUNCTIONS -----
C00023 00008 ! ----- GET_TOKEN variables -----
C00025 00009 ! ----- FILE BOOKEEPING variables -----
C00026 00010 ! read,read_token,read_until,get_more_input
C00039 00011 ! read, push_macro_delimiters
C00050 00012 ! begin_P, end_P, open_paren_P
C00056 00013 ! declare_P
C00061 00014 ! open_P,close_P
C00066 00015 RECURSIVE PROCEDURE P_STATEMENT
C00071 00016 ! INITIALIZATION
C00072 ENDMK
C⊗;
comment ⊗
BEGIN
FLAGS: BAIL$ $D :debugging version
POINTY$ $P :pointy parser
AL$ $A :al parser
ALPOINTY$ =TRUE $B :used in both parsers
INITIALIZATION
P EXP
P STATEMENTS
END ⊗;
preload_array(name, defs, type, first, len)=[
preload_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
TYPES OF TESTS:
actual string
res_word &type_of_res_word
type_of_token
exp_type
exp_dimen
id_type
id
exp
id_type
exp_type
! statement, operator;
redefine xx(str,str2,str3,str4)=[
redefine index_count=index_count+1;
redefine id_count=id_count+1;
redefine xx_temp="define " & "str" & "_index=index_count";
redefine id_temp="define " & "str" & "_id=id_count";
xx_temp; id_temp;];
redefine yy(str,str2,str3,str)=[
redefine type_count=type_count+1;
redefine index_count=0;
redefine yy_temp="define " & "str" & "_type=type_count";
yy_temp;];
redefine zz(str,str2,str3,str4)=[
redefine class_count=class_count+1;
redefine type_count=0;
redefine index_count=0;
redefine zz_temp="define " & "str" & "_class=class_count";
zz_temp;];
define statement_definitions=[
ZZ(BLOCK)
YY(BEGIN, stlst, END)
YY(COBEGIN, stlst, COEND)
ZZ(END)
YY(END)
YY(COEND)
YY([;])
ZZ(STATEMENT)
YY(COMMENT)
XX(COMMENT, anything, )
YY(DECLARE)
XX(SCALAR, undlst)
XX(VECTOR, undlst)
XX(ROT, undlst)
XX(FRAME, undlst)
! XX(PLANE) ;
XX(TRANS, undlst)
XX(EVENT, undlst)
! XX(ATOM)
XX(WORLD)
XX(CM_LABEL)
XX(CLC_LABEL)
XX(CH_LABEL) ;
XX(LABEL, undlst)
YY(OPEN_PAREN)
XX([(], as-is, [)])
YY(GLOBAL)
YY(IF)
xx(IF, ae, THEN, st)
xx(IF, ae, THEN, st, ELSE, st)
YY(PLAN)
YY(WHILE)
XX(WHILE, se, DO, st)
YY(FOR)
xx(FOR, sc, ←, sce, STEP, sce, UNTIL, sce, DO, st)
YY(MOVE)
XX(VIA)
XX(WITH)
XX(APPROACH)
XX(ARRIVAL)
XX(DEPARTURE)
XX(MOVE, fr, TO, fre)
XX(MOVE, fr, TO, fre, clauses)
XX(OPEN, hn, TO, sce)
XX(CLOSE, hn, TO, sce)
XX(CENTER, ar)
XX(STOP, fr)
XX(WOBBLE)
YY(AFFIX, fr, TO, fr)
YY(UNFIX, fr, FROM, fr)
YY(SIGNAL)
XX(SIGNAL, ev)
XX(WAIT, ev)
YY(WHEN)
YY(DUMP)
XX(DUMP, idl)
YY(ASSERT)
XX(ASSERT)
XX(DENY)
YY(ON)
YY(DEFER)
! YY(REFERENCE) ;
YY(SPEED_FACTOR)
YY(DEFINE)
YY(REQUIRE)
XX(SOURCE_FILE)
XX(DELIMITERS)
XX(UNSTACK_DELIMITERS)
XX(REPLACE_DELIMITERS)
XX(MESSAGE)
XX(ERROR_MODES)
XX(COMPILER_SWITCHES)
XX(COMMENT_DELIMITERS)
XX(BAIL)
YY(DIMENSION)
XX(DIMENSION, ud, =, dimexp)
YY(UNIT)
YY(ABORT)
YY(PRINT)
YY(PAUSE)
XX(PAUSE, sce);
YY(NOTE)
XX(NOTE)
XX(NOTE1)
XX(NOTE2)
YY(ENABLE)
XX(ENABLE)
XX(DISABLE)
];
define operator_classes=[
ZZ(COMMA)
yy([,])
ZZ(OR)
yy([∨], or_X)
ZZ(AND)
yy([∧], and_X)
ZZ(NOT)
yy([¬], not_X)
ZZ(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
ZZ(ABS)
yy([|])
ZZ(EXP)
yy([+], plus_X)
yy([-], minus_X)
ZZ(FACTOR)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy(WRT, wrt_X)
ZZ(PF)
yy(→, →_X)
yy([↑], stos_X)
ZZ(FUNC)
yy([#],, nomv_X)
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
ZZ(CLOSE_PAREN)
yy([)])
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
! hash, check_entry, insert_entry;
INTEGER PROCEDURE HASH(STRING S);
α INTEGER I,TOT,C;
C←LENGTH(S); TOT←0;
FOR I←1 STEP 1 UNTIL C DO TOT←TOT+I*LOP(S);
RETURN(TOT MOD HASHER);
β;
RPTR(SYMBOL) PROCEDURE CHECK_ENTRY(STRING S);
α RPTR(SYMBOL) S1;
S1←SYMBOL_BUCKET[SYMTAB_PTR←HASH(S)];
WHILE S1≠NULL_RECORD AND ¬EQU(S,SYMBOL:NAME[S1]) DO S1←SYMBOL:NEXT[S1];
RETURN(S1);
β;
RPTR(SYMBOL) PROCEDURE INSERT_ENTRY(STRING S, INTEGER S2(-1));
α RPTR(SYMBOL) S1;
IF S2≥0 THEN SYMTAB_PTR←HASH(S) ELSE SYMTAB_PTR←S2;
S1←NEW_RECORD(SYMBOL);
SYMBOL:NAME[S1]←S;
SYMBOL:NEXT[S1]←SYMBOL_BUCKET[SYMTAB_PTR];
SYMBOL:LAST[S1]←TOP_SYMBOL;
SYMBOL_TABLE[SYMTAB_PTR]←S1;
TOP_SYMBOL←S1;
RETURN(S1);
β;
! ------- DECLARATIONS ----------;
external integer
rpgsw;
IFC AL$ THENC
RPTR(file)
AL_file, ! current AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file, ! ALC listing file;
LOG_file, ! LOG listing file;
NEW_file; ! new AL file for modified AL program;
ELSEC
RPTR(file)
PTY_file, ! collects terminal output;
READ_file, ! current readin file;
WRITE_file; ! current write file;
ENDC
BOOLEAN
AUTO_PROCEED, ! TRUE if auto_proceed switch is on for error fixup;
LOGGING, ! TRUE if errors to be logged;
COMPILE_LOGGING, ! TRUE if logging wanted trhough require statement;
LOG_FILE_OPEN, ! TRUE if there is a LOGGING file open;
STRICT_DIMEN_CHECK; ! TRUE if dimensions must be checked strictly;
INTEGER
CHANIN, ! current input channel number;
CHANSEX, ! sexfile channel number;
CHANLOG, ! channel of logging file;
CHANNEW; ! channel for new AL file;
IFC BAIL$ THENC
INTEGER
CHANTTYO; ! s-expression output on tty for examination;
ENDC
! ----- SYMBOL TABLE variables ----- ;
RCLASS
SYMBOL(
STRING
NAME;
RPTR(SYMBOL)
NEXT; ! points to next record with same hash key;
INTEGER
WORD1, ! keeps track of what type token this symbol is, e.g. macro,
reserved, id, etc.
WORD2; ! points to last declared SYMBOL record, used for deleting
declarations when exiting block;
IFC AL$ THENC
RPTR(DIMENS,MACRO)
PTR ! points to data record depending on what type
ELSEC of symbol;
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)
PTR
ENDC
);
RPTR(SYMBOL) ARRAY
SYMBOL_BUCKET[0:hasher-1];
define
undeclared_token = 0,
id_token = 1,
reserved_token = 2,
macro_token = 3,
dimen_token = 4,
numeric_token = 5,
string_token = 6;
RPTR(SYMBOL)
LAST_SYMBOL_PTR;
INTEGER
SYMTAB_KEY; ! points to symbol table;
IFC AL$ THENC
RCLASS
DIMEN(
INTEGER
DISTANCE,
TIME,
FORCE,
ANGLE
);
RCLASS
PARAM_LIST(
STRING
PARAM, ! parameter itself;
DUMMY; ! internal parameter;
RPTR(PARAM_LIST)
NEXT ! pointer to next param_list record;
);
RCLASS
MACRO(
STRING
BODY;
INTEGER
DELIMITERS, ! two characters squeezed into this number;
NPARAMS;
RPTR(PARAM_LIST)
PARAM_PTR
);
ENDC
IFC POINTY$ THENC
RCLASS
SCALAR(
REAL
VALUE);
RCLASS
VECTOR(
REAL
X,
Y,
Z);
RCLASS
ROT(
REAL ARRAY
XF[1:5,1:4]);
RCLASS
FRAME(
STRING
NAME;
RPTR(FRAME)
DAD,
SON,
EBRO,
YBRO;
INTEGER
HOWLINKED;
REAL ARRAY
XF[1:5,1:4]);
RCLASS
TRANS(
STRING
NAME;
REAL ARRAY
XF[1:5,1:4]);
ENDC
! ----- SYMBOL TABLE EXTRACTION AND INSERTION FUNCTIONS -----;
! AL$ XXXX XXXXX XXXXX XXXX XXXXX
POINTY$ XXXX XXXXX XXXX XXXXX
NAME WORD1 WORD2 NEXT PTR PTR
RESERVED XXXX XXXXX XXXXX XXXX ---- -----
ID XXXX XXXXX XXXXX XXXX DIMEN SCALAR,VECTOR,ROT,FRAME
AL$ only
DIMEN XXXX XXXXX XXXXX XXXX DIMEN
MACRO XXXX XXXXX XXXXX XXXX MACRO
WORD1
0 1 2 3
0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_
| LAST |TYPE | INDEX | CLASS | RESERVED
| LAST (8) |TYPE | INDEX | | FLAGS ID
| LAST (8) |TYPE | DIMEN
| LAST (8) |TYPE | | FLAGS MACRO
WORD2
0 1 2 3
0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_6_7_8_9_0_1_2_3_4_5_
RESERVED
| FILE 5 | PAGE 7 | LINE 10 | ID
| FILE 5 | PAGE 7 | LINE 10 | DIMEN
| FILE 5 | PAGE 7 | LINE 10 | MACRO
define symbol_masks =(
xx(SYMBOL_LAST, 1, '776000000000, '2000000000)
xx(SYMBOL_TYPE, 1, '1600000000, '200000000)
xx(SYMBOL_INDEX,1, '174000000, '4000000)
xx(SYMBOL_CLASS,1, '3774000, '4000)
xx(SYMBOL_FLAGS,1, '3777, '2000)
xx(SYMBOL_FILE, 2, '760000000000, '20000000000)
xx(SYMBOL_PAGE, 2, '17700000000, '100000000)
xx(SYMBOL_LINE, 2, 77740000, '40000)
);
sym_mask_count=0;
redefine xx(str1,i1,i2,i3)=[
redefine sym_mask_count=sym_mask_count+1;
define str1=sym_mask_count];
symbol_masks;
define zap_sym(name,type,arg)=[
redefine xx(str1,i1,i2,i3) = [arg,];
preload_array(name,symbol_masks,type,1,sym_mask_count)];
zap_sym(sym_mask,integer,i2);
zap_sym(sym_mod,integer,i3);
INTEGER PROCEDURE GET(RPTR(SYMBOL) R1; INTEGER FIELD);
RETURN(IF FIELD≤SYMBOL_FLAGS
THEN ((SYMBOL:WORD1[R1] LAND SYM_MASK[FIELD])MOD SYM_MOD[FIELD])
ELSE ((SYMBOL:WORD2[R1] LAND SYM_MASK[FIELD])MOD SYM_MOD[FIELD]));
PROCEDURE PUT(RPTR(SYMBOL) R1; INTEGER FIELD,VALUE);
IF FIELD≤SYMBOL_FLAGS
THEN SYMBOL:WORD1[R1]←((SYMBOL:WORD1[R1] LAND LNOT SYM_MASK[FIELD])+VALUE*SYM_MOD[FIELD])
ELSE SYMBOL:WORD2[R1]←((SYMBOL:WORD2[R1] LAND LNOT SYM_MASK[FIELD])+VALUE*SYM_MOD[FIELD]);
PROCEDURE GET3(RPTR(R1); REFERENCE INTEGER TYPE,CLASS,INDEX);
α INTEGER WORD; WORD←SYMBOL:WORD1[R1];
TYPE ← (WORD LAND LNOT SYM_MASK[SYMBOL_TYPE])+VALUE*SYM_MOD[SYMBOL_TYPE];
CLASS← (WORD LAND LNOT SYM_MASK[SYMBOL_CLASS])+VALUE*SYM_MOD[SYMBOL_CLASS];
INDEX← (WORD LAND LNOT SYM_MASK[SYMBOL_INDEX])+VALUE*SYM_MOD[SYMBOL_INDEX];
β;
! ----- GET_TOKEN variables ----- ;
STRING
CURLINEP, ! amount of current line already parsed;
CURLINER, ! amount of current line remaining to be parsed;
CURLINE; ! current line: CURLINE = CURLINEP&TOKEN&CURLINER;
RCLASS
TOKEN(
STRING
TOKEN;
INTEGER
TYPE,
CLASS,
INDEX,
LEVEL;
IFC AL$ THENC
RPTR(DIMENS)
ELSEC
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)
ENDC
PTR);
RPTR(TOKEN)
TOKENP;
! ----- ERROR RECOVERY flags ----- ;
BOOLEAN
MODIFY ! error may be modified by backing up;
MODIFIED; ! source code has been changed;
STRING
PARSED_STRING, ! string parsed but s-expression not output;
OUTSTRING; ! string of s-expression terms;
! ----- FILE BOOKEEPING variables ----- ;
RCLASS
FILEDATA(
integer
chn, comment channel on which file accessible;
fileno;
string
name,
ext,
ppn,
device,
def_ext;
boolean
out;
integer
mode, comment OPEN type info;
eof,
brchr,
count,
in_bfrs,
out_bfrs;
RPTR(FILEDATA)
next
);
RPTR(FILEDATA)
FILE_PTR,
FILE_PTR_HEAD;
! read,read_token,read_until,get_more_input;
TOKEN TOKEN_TYPE TOKEN_CLASS TOKEN_INDEX TOKEN_PTR
ID XXXXX ID_TOKEN XXXXXXX XXXXXXX
SCALAR_VALUE
VECTOR_VALUE
ETC
DIMEN XXXXX DIMEN_TOKEN XXXXXXX
RESERVED XXXXX RESERVED_TOKEN XXXXXXX XXXXXXX ???????
STATEMENT further subclass
OPERATOR
FUNCTION
MACRO XXXXX MACRO_TOKEN no. of args
substitution of macro parameters XX(A,B,C,etc)
→ XX(<bs>1<bs>A,<bs>2<bs>B,<bs>3<bs>C>)
TOKEN CLASSIFICATIONS:
alphabets a-z,A-Z 52
digits 0-9 10
underscore 1
delimiters cr,lf,tab,ff,sp,dquote,',` 8
relational ≤≥<>≠= 6
balanced pairs ()[]{}∩∪⊂⊃←→↑↓∧∨ 16
greek letters αβελπ∂ 6
single letters ↔∀∃!,?.;:∞/\&#@*⊗¬+|~%$≡∞ 25
non-E char bs,alt,vt,nul 4
total 128
PROCEDURE READ();
α
TOKEN_H←READ_TOKEN(NON_BLANK_BREAK,BRCHAR);
IF "A"≤BRCHAR≤"Z" OR "a"≤BRCHAR≤"z" OR BRCHAR="_"
THEN α TOKEN2←READ_TOKEN(ID_BREAK,BRCHAR);
IF (TOKEN_PTR←CHECK_ENTRY(TOKEN))≠NULL_RECORD
THEN α GET3(TOKEN_PTR,TOKEN_TYPE,TOKEN_CLASS,TOKEN_INDEX);
CASE TOKEN_TYPE OF
α
[reserved_TOKEN]
[dimen_TOKEN] ;
[id_TOKEN]
[macro_TOKEN]
IF MACRO:NPARAMS[DATA_PTR] = 0
THEN substitute for body
ELSE read real parameters;
β;
ELSE TOKEN_CLASS←undeclared_TOKEN;
β
ELSE IF "0"≤BRCHAR≤"9" OR BRCHAR="."
THEN TOKEN2←READ_TOKEN(NUMERIC_TOKEN,BRCHAR)
ELSE IF BRCHAR=DQUOTE
THEN TOKEN2←READ_TOKEN(STRING_TOKEN_BREAK,BRCHAR)
ELSE IF BRCHAR=COMMENT_OPEN_DELIMITER
THEN TOKEN2←READ_TOKEN(COMMENT_DELIMITER_BREAK,BRCHAR);
β;
STRING PROCEDURE READ_TOKEN(INTEGER BTABLE; REFERENCE INTEGER BRCHAR);
α STRING S1,S2;! s1 to be returned, s2 is processed part of string;
IF BTABLE=NON_BLANK_BREAK
THEN S1←S2←READ_UNTIL(BTABLE,BRCHAR)
ELSE IF BTABLE=ID_BREAK
THEN S1←S2←SCAN(CURLINER,ID_BREAK,BRCHAR)
ELSE IF BTABLE=NUMERIC_BREAK
THEN α INTEGER BRCHAR1,I1;
S1←S2←SCAN(CRULINER,NUMERIC_BREAM,BRCHAR);
I1←REALSCAN(S1,BRCHAR1);
IF S1=NULL
THEN α TOKEN_VALUE←I1; S2←S1; β
ELSE α CURLINER←S2&CURLINER;
S1←S2←LOP(CURLINER);
β;
β
ELSE IF BTABLE=DQUOTE_BREAK
THEN α S2←LOP(CURLINER);S1←S3←NULL;
WHILE CURLINER[1 TO 1]=DQUOTE
DO α S2←S1&DQUOTE&(S3←READ_UNTIL(DQUOTE,BRCHAR));
S2←S2&S3&LOP(CURLINER);
β;
β;
RETURN(S1);
β;
STRING PROCEDURE READ_UNTIL(INTEGER BTABLE, REFERENCE INTEGER BRCHAR);
α STRING S1;
S1←SCAN(CURLINER,BTABLE, BRCHAR);
WHILE BRCHAR=NULL AND ¬EOF
DO α GET_MORE_INPUT;
S1←S1&SCAN(CURLINER, BTABLE,BRCHAR);
β;
RETURN(S1);
β;
PROCEDURE GET_MORE_INPUT;
α IF CHANIN>-1 THEN CURLINE←CURLINER←INPUT(CHANIN,LF_FF_BREAK,BRCHAR);
IF CHANIN≤-1
THEN POP_MACRO
ELSE IF BRCHAR=LF
THEN LINENUM←LINENUM + 1
ELSE IF BRCHAR=FF
THEN α OUTSTR(NEWPAGE NUM); PAGENUM←PAGENUM+1; β
ELSE IF TOP_SOURCE≠NULL
THEN CLOSE_SOURCE
ELSE RETURN(NULL);
β;
! read, push_macro_delimiters;
INTEGER BRCHAR2;
STRING PROCEDURE KNVRT(STRING OLD_STR);
RETURN( SCAN(OLD_STR, KNVRT_BREAK, BRCHAR2));
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT,TEXT2;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN > -1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT;
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN>-1 THEN α STRING CURR;
CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
IF CHANTTYO≥0 THEN OUT(CHANTTYO, CURLINE);
macro_stack_top←macro_st2; macro_st2←null_record;β;
IF CHANIN≤-1 THEN
α "pop macro"
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
macro_st2←SOURCE_LIST:macro_stack_TOP[TOP_SOURCE];
CURRENT_MACRO←SOURCE_LIST:CUR_MACRO[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
IF (BTABLE=WORD_r_BREAK) OR (BTABLE=word_s_break) OR (BTABLE=non_digit_break)
then α brchar←space; return(text); β;
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
printout;
RELEASE(CHANIN); RELEASE(CHANNEW);
IF EQU(FILE:DEVICE[PRESENT_FILE],"TTY") THEN RELEASE(CHANTTYO);
CURRENT_MACRO←NULL_RECORD;
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←POP_SOURCE_LIST(TOP_SOURCE);
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN
IF BLOCK_LEVEL > 1
THEN ERROR(500,"end of file encountered unexpectedly.")
ELSE RETURN(NULL);
TEXT2←SCAN(CURLINER,BTABLE,BRCHAR);
IF CHANIN>-1 THEN
IF (BTABLE=WORD_S_BREAK) OR (BTABLE=CLOSE_BRACE_BREAK) OR (BTABLE=QUOTE_BREAK)
OR (BTABLE=MACRO_DELIMITER_BREAK)
OR (BTABLE=OMIT_BREAK) OR (BTABLE=TTY_INPUT_BREAK)
THEN PARSED_STRING←PARSED_STRING&TEXT2&BRCHAR
ELSE PARSED_STRING←PARSED_STRING&TEXT2;
TEXT←TEXT&TEXT2;
β;
TOKEN2←TEXT;
ifc full_set thenc RETURN(knvrt(TEXT)); elsec RETURN(TEXT); ENDC
β;
! begin_P, end_P, open_paren_P;
RECURSIVE PROCEDURE BEGIN_P;
α INTEGER SAVE_DEC_NUM; RANY RR;
EXTERNAL RANY PROCEDURE $REC$(INTEGER OP; RANY R);
STRING B1,B2,E1,E2,TT; STRING S, BLK_NAME, BLK_NAME_END;
TT←"("&LABL;
B1←B2←"BEGIN";
E1←E2←"END";
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
IF EQU(TOKEN,"BEGIN")
THEN α B2←"CO"&B2;E2←"CO"&E2;TT←TT&"BL";β
ELSE α B1←"CO"&B1;E1←"CO"&E1;TT←TT&"CO";β;
PRINT(TT); printout;
GET_TOKEN;
IF TOKEN_TYPE=STRING_TOKEN
THEN BLK_NAME←TOKEN
ELSE α BLK_NAME←NULL; REJECT←TRUE; β;
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,E1) DO
α
P_STATEMENT;
IF TYPE_OF_RES_WORD≠end_RES
THEN ERROR("Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,E2) THEN
α ERROR(5,"Block ends with " & E2 & crlf
& "Continue will view as "& E1);
TOKEN←E1;
β;
PRINTOUT;
β;
GET_TOKEN;
IF TYPE_OF_TOKEN=STRING_TOKEN
THEN BLK_NAME_END←TOKEN
ELSE α BLK_NAME_END←NULL; REJECT←TRUE; β;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
IF ¬(EQU(BLK_NAME,BLK_NAME_END) OR EQU(BLK_NAME_END,NULL))
THEN ERROR(600, "Block name at end does not agree with that at beginning.");
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α
SYMBOL_TABLE[HASH(SS←SYMBOL:NAME[TOP_SYMBOL],hasher)]
← SYMBOL:NEXT[TOP_SYMBOL];
TOP_SYMBOL←SYMBOL:LAST[RR←TOP_SYMBOL];
$REC$(5,RR);
β;
DEC_NUM←SAVE_DEC_NUM;
PRINT(")");
PRINTOUT;
β;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);PRINTOUT;
β;
! declare_P;
procedure declare_P;
α
STRING BUILD_OUT; INTEGER DECLARATION_TYPE;
RPTR(DIMENS_EXPONENT)DIM;
DECLARATION_TYPE←TOKEN_INDEX;
IF DIM_PTR=NREC THEN
CASE SPECIAL_INFO OF
α
[scalar_VALUE]
[vector_VALUE] DIM←NIL_DIMENS;
[rot_VALUE] DIM←ANGLE_DIMENS;
[trans_VALUE]
[frame_VALUE] DIM←DISTANCE_DIMENS;
ELSE DIM←NULL_RECORD
β;
BUILD_OUT←"("&LABL&DEC_NAME[DECLARATION_TYPE]
GET_TOKEN;
DO α
CASE TOKEN_CLASS OF
α
[numeric_token] ERROR(XX,"TOKEN is numeric");
[string_token] ERROR(XX,"TOKEN is a string");
[reserved_token] ERROR(XX,"TOKEN is a reserved word");
[id_token]
IF TOKEN_LEVEL=BLOCK_LEVEL
THEN ERROR(XX,"TOKEN already declared on this block");
ELSE IF TOKEN_LEVEL=0
THEN ERROR(XX,"TOKEN is a predeclared constant.");
[undeclared_token] ;
ELSE ERROR(XX,"TROUBLE - shouldnt get here")
β;
BUILD_OUT←BUILD_OUT&" "&TOKEN;
P1←INSERT_ENTRY(TOKEN);
NEW_ID(DECLAR_TYPE,DIM_PTR);
GET_TOKEN;
IF EQU(TOKEN,",") THEN GET_TOKEN
ELSE IF ¬EQU(TOKEN,";") THEN ERROR_REJECT(7,"Missing comma.");
β UNTIL EQU(TOKEN,";");
PRINT(BUILD_OUT&" )");
β;
! open_P,close_P;
PROCEDURE open_P;
α STRING S,HAND; S←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"BHAND") AND ¬EQU(TOKEN,"YHAND")
THEN ERROR("Need a hand after "&TOKEN);
ELSE HAND←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN ERROR("Require TO here");
P_EXP;
CHECK_EXP_DIMENS_TYPE(DISTANCE_DIMENS," after "&S&" statement");
PRINT("( MO "&HAND&space4&OUTEXPR&" )");
β;
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(MOVE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
xx(WHEN)
xx(DUMP)
xx(ASSERT)
yy(DENY)
xx(ON)
yy(DEFER)
xx(CENTER)
xx(STOP)
xx(SPEED_FACTOR)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
xx(COMMENT)
xx(ABORT)
yy(PRINT)
yy(PAUSE)
xx(NOTE)
yy(NOTE1)
yy(NOTE2)
xx(ENABLE)
xx(DISABLE)
];
define operator_classes=[
zz(COMMA)
yy([,])
xx(OR, or_X)
yy([∨], or_X)
xx(AND, and_X)
yy([∧], and_X)
xx(NOT, not_X)
yy([¬], not_X)
zz(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
zz(ABS)
yy([|])
yy(VVVTRANS)
zz(ADD)
yy([+], plus_X)
yy([-], minus_X)
zz(MULT)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy([⊗], vcross_X)
yy(WRT, wrt_X)
yy(VVROT, vvrot_X)
zz(TRANS)
yy(→, →_X)
yy([↑], stos_X)
zz(VECTOR)
yy([#],, nomv_X)
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
! zz(SCALAR)
yy(ANGLE, angle_X);
zz(CLOSE_PAREN)
yy([)])
];
define require_definitions=[
xx(SOURCE_FILE)
xx(DELIMITERS)
xx(UNSTACK_DELIMITERS)
xx(REPLACE_DELIMITERS)
xx(MESSAGE)
xx(ERROR_MODES)
xx(COMPILER_SWITCHES)
xx(COMMENT_DELIMITERS)
xx(BAIL)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(APPROACH)
yy(ARRIVAL)
yy(DEPARTURE)
xx(WOBBLE)
xx(DIRECTLY)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
sex_RES =-2,
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
STRING LABL; RPTR DIM_PTR; LABEL RE_TRY; RE_TRY_0;
INTEGER SAVSPACING;
SAVSPACING←SPACING;
RE_TRY_0:
SPACING←SAVSPACING;
GET_TOKEN;
RE_TRY:
CASE TOKEN_TYPE OF
α
[string_TOKEN] ignore;
[undeclared_TOKEN]
α "undeclared token"
STRING TOKEN_SAVE,SS; TOKEN_SAVE←TOKEN; GET_TOKEN;
CASE TOKEN OF
α
["←"] α GET_TOKEN;
IF TOKEN = "←" THEN SS←SS&" PAS"
ELSE α SS←SS& " AS"; REJECT←TRUE; β;
P_EXP;
ERROR("UNDECLARED TOKEN "&TOKEN_SAVE&" WILL BE DECLARED "
&"A VARIABLE OF TYPE"&DATA_NAME[ID_TYPE]
&" DIMENSIONS PUT IN LATER");
MAKE_NEW_ID(TOKEN_SAVE,EXP_TYPE,EXP_DIMEN);
! ****** DECLARE TYPE HERE******;
PRINT("( "&LABL&SS); SPACING←SPACING + 1;
PRINT(OUTEXPR); SPACING←SPACING - 1;
PRINT(")");
β;
["<"] ERROR ("CHANGER NOT VALID YET");
[":"] α ERROR(TOKEN_SAVE&" WILL BE DECLARED A LABEL");
USED(MAKE_NEW_ID(TOKEN_SAVE,LABEL_TYPE));
GO_TO RE_TRY_0;
β;
ELSE ERROR("CANNOT HAVE "&TOKEN&" AFTER "&SS)
β;
[id_TOKEN]
IF ID_TYPE = LABEL_TYPE
THEN
α
IF UNUSED(TOKEN_PTR)
THEN α LABL ← LABL & TOKEN & " "; USED(TOKEN_PTR); β
ELSE ERROR("LABEL "&TOKEN&" HAS ALREADY BEEN USED");
IF ¬NEXT_TOKEN_EQU(":")
THEN ABORT("NEED COLON AFTER LABEL")
ELSE GOTO RE_TRY;
β
ELSE
α RPTR(ID) ID_PTR;
ID_PTR←TOKEN_PTR;SS←TOKEN; GET_TOKEN;
CASE TOKEN OF
α
["←"] α GET_TOKEN;
IF TOKEN = "←" THEN SS←SS&" PAS"
ELSE α SS←SS& " AS"; REJECT←TRUE; β;
P_EXP;
CHECK_EXP_TYPE(ID:TYPE[ID_PTR]);
CHECK_EXP_DIMEN(ID:DIMEN[ID_PTR]);
PRINT("( "&LABL&SS); SPACING←SPACING + 1;
PRINT(OUTEXPR); SPACING←SPACING - 1;
PRINT(")");
β;
["<"] ERROR ("CHANGER NOT VALID YET");
ELSE ERROR("CANNOT HAVE "&TOKEN&" AFTER "&SS)
β;
β;
[numeric_TOKEN]
ERROR("STATEMENT CANNOT BEGIN WITH A NUMERIC CONSTANT");
[dimen_TOKEN]
α DIM_PTR←TOKEN_PTR; GET_TOKEN;
IF ¬EQU(TOKEN,"SCALAR") OR ¬EQU(TOKEN,"VECTOR") OR ¬EQU(TOKEN,"TRANS")
THEN
ERROR("ONLY SCALARs, VECTORs,or TRANSes MAY BE DECLARED WITH DIMENSIONS")
ELSE DECLARE_P;
β;
[reserved_TOKEN]
IF (statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end)
THEN CASE TYPE_OF_RES_WORD - statement_beg OF
α
statement_definitions;
β
ELSE ERROR("STATEMENT CANNOT BEGIN WITH RESERVED WORD "&TOKEN);
ELSE ERROR("PARSER ERROR, SEND MESSAGE TO MSM");
β
β "P_STATEMENT";
! INITIALIZATION;
READ IN RESERVED WORDS TABLE;
READ IN PREDEFINED MACROS
READ IN PREDEFINED CONSTANTS;